home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 26
/
Cream of the Crop 26.iso
/
program
/
qbsnip.zip
/
TEXTMELT.BAS
< prev
next >
Wrap
BASIC Source File
|
1997-06-20
|
3KB
|
106 lines
'Graphics melt #1 and #2
'
'3/2/1997 By: - Nick Kochakian -
'
'This melts any graphic you put a "box" around.
'
'If you have any comments or questions e-mail me at: nickK@worldnet.att.net
'
'Have fun! :)
' Modified by Tika Carr (t.carr@pobox.com) on June 20, 1997
' o Optimized the code some
' o Made into a callable subroutine
' o You can now position text anywhere on the screen and have it melt
' o Delay loop will ensure proper melt speed, no matter what size the
' message is.
' o Added the ability to melt with another color (nice for "bleeding"
' messages!
' o Checks to be sure string is not too long
'
' This is NOT a transparent text.
' Press any key at any time to go to the next stage of the demo
DEFINT A-Z
DECLARE SUB MeltMsg (mx%, my%, message$, style%, TxtClr%, MeltCol%)
SCREEN 13 ' only works in 320 x 200 x 256 mode
'MeltMsg x, y, message$, sytle, color of text, color of melting
'style = 1 'The way to melt the graphic / text on the screen
'style = 2 'boil / blend
MeltMsg 6, 3, "Here's a Toxic Blood Effect!", 1, 10, 12
CLS
MeltMsg 10, 10, "A boiling effect", 2, 13, 13 'same color can also be used
SCREEN 0, 0, 0, 0: WIDTH 80: COLOR 7, 0: CLS : END
SUB MeltMsg (mx, my, message$, style, TxtClr, MeltCol)
strlen = LEN(message$) + 1
IF strlen > 40 THEN
SCREEN 0, 0, 0, 0: WIDTH 80: COLOR 7, 0: CLS
PRINT "ERROR: String too long"
END
END IF
RANDOMIZE TIMER
DIM x(10000), y(10000), c(10000), o(10000)
IF style < 1 OR style > 2 THEN style = 1 ' Ensure proper melt defaults
COLOR TxtClr: LOCATE my, mx: PRINT message$
'Calculate delay based on size of string
'The larger the string, the less delay time (as it takes longer to render)
SELECT CASE strlen
CASE IS < 31: delay = 10000
CASE IS < 20: delay = 20000
CASE IS < 10: delay = 30000
CASE ELSE: delay = 0
END SELECT
x2 = 8 * (mx + strlen) - 16: y2 = 8 * (my - 1) + 8: x = mx: y = my
x1 = x: y1 = y: px = 1: py = 1: pc = 1: onc = 1: pixcnt = 0
DO
IF POINT(x, y) > 0 THEN
'col = POINT(x, y)
'col = 14
x(px) = x: y(py) = y: c(pc) = MeltCol
px = px + 1: py = py + 1: pc = pc + 1: pixcnt = pixcnt + 1
END IF
x = x + 1: IF x > x2 THEN x = x1: y = y + 1
LOOP UNTIL y > y2
'px = px + 1: py = py + 1
x(px) = -1: y(py) = -1
px = 1: py = 1: pc = 1
WHILE INKEY$ = ""
DO
numend = INT(RND * pixcnt) + 1
FOR i = 1 TO numend
px = px + 1: py = py + 1: pc = pc + 1: onc = onc + 1
NEXT
oncbak = onc: onc = 1: onccntr = 0
FOR i = 1 TO pixcnt: onc = onc + 1: onccntr = onccntr + 1: NEXT
IF onccntr = pixcnt THEN
onc = oncbak: onc = 1
FOR i = 1 TO pixcnt: o(onc) = 0: onc = onc + 1: NEXT: onc = 1
END IF
LOOP WHILE o(onc) = 1
IF style = 2 THEN PSET (x(px), y(py)), 0
y(py) = y(py) + 1: PSET (x(px), y(py)), c(pc): o(onc) = 1
px = 1: py = 1: pc = 1: onc = 1
IF delay > 0 THEN FOR i = 1 TO delay: NEXT
WEND
END SUB